Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH4/SRC/BRIGHT.FRM

Visual Basic Form | 1997-01-03 | 18.9 KB | 600 lines

VERSION 4.00
Begin VB.Form BrightForm
   Caption         =   "Brightness"
   ClientHeight    =   4470
   ClientLeft      =   1380
   ClientTop       =   915
   ClientWidth     =   4695
   Height          =   5160
   Left            =   1320
   LinkTopic       =   "Form1"
   ScaleHeight     =   298
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   313
   Top             =   285
   Width           =   4815
   Begin VB.PictureBox BalPict
      BorderStyle     =   0  'None
      Height          =   255
      Left            =   0
      ScaleHeight     =   255
      ScaleWidth      =   4695
      TabIndex        =   4
      Top             =   4200
      Width           =   4695
      Begin VB.HScrollBar ScrollBright
         Enabled         =   0   'False
         Height          =   255
         LargeChange     =   10
         Left            =   380
         Max             =   100
         Min             =   -100
         TabIndex        =   5
         Top             =   0
         Width           =   4350
      End
      Begin VB.Label ValueBright
         BorderStyle     =   1  'Fixed Single
         Caption         =   "0"
         Height          =   255
         Left            =   0
         TabIndex        =   6
         Top             =   0
         Width           =   375
      End
   End
   Begin VB.PictureBox FromSwin
      Height          =   3855
      Left            =   0
      ScaleHeight     =   253
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   293
      TabIndex        =   2
      Top             =   0
      Width           =   4455
      Begin VB.PictureBox FromPict
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         Height          =   1905
         Left            =   0
         ScaleHeight     =   123
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   88
         TabIndex        =   3
         Top             =   0
         Width           =   1380
      End
   End
   Begin VB.HScrollBar FromHBar
      Enabled         =   0   'False
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   3840
      Width           =   4485
   End
   Begin VB.VScrollBar FromVBar
      Enabled         =   0   'False
      Height          =   3855
      Left            =   4440
      TabIndex        =   0
      Top             =   0
      Width           =   255
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   4200
      Top             =   3600
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSep2
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "BrightForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer
Dim bytes() As Byte
Dim wid As Long
Dim hgt As Long
Dim LogPal As Integer
Dim origpal(0 To 255) As PALETTEENTRY
Dim newpal(0 To 255) As PALETTEENTRY
Dim SettingValues As Boolean
' ***********************************************
' Load the control's palette so the non-static
' colors are grays. Map the logical palette to
' match the system palette. Convert the image to
' use the non-static grays.
' Set the following module global variables.
'   LogPal      Image logical palette handle.
'   origpal()  Image logical palette entries.
'   wid         Width of image.
'   hgt         Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchGrayPalette(pic As Control)
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim X As Integer
Dim Y As Integer
Dim gray As Single
Dim dgray As Single
Dim c As Integer
Dim clr As Integer
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Make the logical palette as big as possible.
    LogPal = pic.Picture.hPal
    If ResizePalette(LogPal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        origpal(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        origpal(i) = sys(i)
    Next i
    i = SetPaletteEntries(LogPal, 0, SysPalSize, origpal(0))
    ' Insert the non-static grays.
    gray = 0
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    For i = StaticColor1 + 1 To StaticColor2 - 1
        c = gray
        gray = gray + dgray
        With origpal(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, origpal(StaticColor1 + 1))
    ' Recreate the image using the new colors.
    For Y = 1 To hgt
        For X = 1 To wid
            clr = bytes(X, Y)
            With sys(clr)
                c = (CInt(.peRed) + .peGreen + .peBlue) / 3
            End With
            bytes(X, Y) = NearestNonstaticGray(c)
        Next X
    Next Y
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Realize the gray palette.
    i = RealizePalette(pic.hdc)
    pic.Refresh
End Sub
' ************************************************
' Return the index of the nonstatic color closest
' to the given color value.
' ************************************************
Function NearestNonstaticColor(ByVal r As Integer, ByVal g As Integer, ByVal b As Integer) As Integer
Dim best_i As Integer
Dim best_dist As Long
Dim dist As Long
Dim dr As Long
Dim dg As Long
Dim db As Long
Dim i As Integer
    best_dist = 1000000
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            dr = r - .peRed
            dg = g - .peGreen
            db = b - .peBlue
            dist = dr * dr + dg * dg + db * db
        End With
        If best_dist > dist Then
            best_i = i
            best_dist = dist
        End If
    Next i
    NearestNonstaticColor = best_i
End Function
' ************************************************
' Return the index of the nonstatic gray closest
' to the given value (assuming the non-static
' colors are a gray scale created by
' MatchGrayPalette).
' ************************************************
Function NearestNonstaticGray(c As Integer) As Integer
Dim dgray As Single
    If c < 0 Then
        c = 0
    ElseIf c > 255 Then
        c = 255
    End If
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    NearestNonstaticGray = c / dgray + StaticColor1 + 1
End Function
' ***********************************************
' Load the control's palette so it matches the
' the system palette. Remap any of the image's
' pixels that use static colors to non-static
' colors.
' Set the following module global variables.
'   LogPal      Image logical palette handle.
'   origpal()  Image logical palette entries.
'   wid         Width of image.
'   hgt         Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchColorPalette(pic As Control)
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim X As Integer
Dim Y As Integer
Dim clr As Integer
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Make the logical palette as big as possible.
    LogPal = pic.Picture.hPal
    If ResizePalette(LogPal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        origpal(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        origpal(i) = sys(i)
    Next i
    i = SetPaletteEntries(LogPal, 0, SysPalSize, origpal(0))
    ' Insert the non-static colors.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        origpal(i) = sys(i)
        origpal(i).peFlags = PC_NOCOLLAPSE
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, origpal(StaticColor1 + 1))
    ' Realize the new palette.
    i = RealizePalette(pic.hdc)
    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Remap any pixels using static colors.
    For Y = 1 To hgt
        For X = 1 To wid
            clr = bytes(X, Y)
            If clr <= StaticColor1 Or clr >= StaticColor2 Then
                With sys(clr)
                    bytes(X, Y) = _
                        NearestNonstaticColor( _
                        .peRed, .peGreen, .peBlue)
                End With
            End If
        Next X
    Next Y
    ' Update the image's pixel values.
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    pic.Refresh
End Sub
' ***********************************************
' Load the indicated file and prepare to work
' with its palette.
' ***********************************************
Sub LoadFromPict(fname As String)
Dim status As Long
Dim i As Integer
    On Error GoTo LoadFileError
    FromPict.Picture = LoadPicture(fname)
    On Error GoTo 0

    FromHBar.Enabled = False
    FromVBar.Enabled = False
    ScrollBright.Enabled = False
    DoEvents
    MatchColorPalette FromPict
    For i = 0 To SysPalSize - 1
        newpal(i) = origpal(i)
    Next i
    FromPict.Move 0, 0
    ResetScrollBars
    ScrollBright.Enabled = True
    SettingValues = True
    ScrollBright.Value = 0
    SettingValues = False

    Caption = "Brightness [" & fname & "]"
    Exit Sub
LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    Exit Sub
End Sub
' ***********************************************
' Set the Max and LargeChange properties for the
' image scroll bars.
' ***********************************************
Sub ResetScrollBars()
    ' FromHBar.
    FromHBar.Value = 0
    If FromSwin.ScaleWidth >= FromPict.Width Then
        FromHBar.Enabled = False
    Else
        FromHBar.Max = FromPict.Width - FromSwin.ScaleWidth
        FromHBar.LargeChange = FromSwin.ScaleWidth
        FromHBar.Enabled = True
    End If
    ' FromVBar.
    FromVBar.Value = 0
    If FromSwin.ScaleHeight >= FromPict.Height Then
        FromVBar.Enabled = False
    Else
        FromVBar.Max = FromPict.Height - FromSwin.ScaleHeight
        FromVBar.LargeChange = FromSwin.ScaleHeight
        FromVBar.Enabled = True
    End If
End Sub
' ************************************************
' Adjust the brightness of the colors.
' If -100 <= v <= 0, then subtract v percent of
' the color components.
' If 0 <= v <= 100, then add v percent of the
' difference between the color components and 255.
' Thus:
'   When v = -100, the color goes to 0.
'   When v =    0, the color is unchanged.
'   When v =  100, the color goes to 255.
' ************************************************
Sub UpdateColors()
Dim i As Integer
Dim v As Single
Dim f As Single
Dim r As Integer
Dim g As Integer
Dim b As Integer
    ' Get the scroll bar value.
    v = ScrollBright.Value / 100#
    If v < 0 Then
        f = 1 + v
    Else
        f = v
    End If
    ' Set the new palette entries.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            r = .peRed
            g = .peGreen
            b = .peBlue
            If v < 0 Then
                r = r * f
                g = g * f
                b = b * f
            Else
                r = r + (255 - r) * f
                g = g + (255 - g) * f
                b = b + (255 - b) * f
            End If
        End With
        With newpal(i)
            .peRed = r
            .peGreen = g
            .peBlue = b
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, newpal(StaticColor1 + 1))
    i = RealizePalette(FromPict.hdc)
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    FromPict.MousePointer = vbHourglass
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    FromPict.MousePointer = vbDefault
End Sub
Private Sub Form_Load()
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If
    ' Get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2
    ' Remove the borders from FromPict.
    FromPict.BorderStyle = vbTransparent
    ' Make sure FromPict has control.
    FromPict.ZOrder
End Sub
' ***********************************************
' Make the picture as large as possible.
' ***********************************************
Private Sub Form_Resize()
Const GAP = 6
Dim hgt As Single
Dim wid As Single
Dim lft As Single
    If WindowState = vbMinimized Then Exit Sub

    hgt = ScaleHeight - FromHBar.Height - 1 - _
        BalPict.Height - 1.5 * GAP
    wid = ScaleWidth - FromVBar.Width - 1
    ' Place FromSwin and its scroll bars.
    FromSwin.Move 0, 0, wid, hgt
    FromVBar.Move _
        FromSwin.Left + FromSwin.Width + 1, _
        0, FromVBar.Width, hgt
    FromHBar.Move _
        FromSwin.Left, FromSwin.Height + 1, _
        wid

    BalPict.Move 0, _
        FromHBar.Top + FromHBar.Height + GAP, _
        ScaleWidth
    ScrollBright.Width = BalPict.ScaleWidth - ScrollBright.Left
    ResetScrollBars
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromHBar_Change()
    FromPict.Left = -FromHBar.Value
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromHBar_Scroll()
    FromPict.Left = -FromHBar.Value
End Sub
' ************************************************
' Present a message indicating the pixel's palette
' index and color value.
' ************************************************
Private Sub FromPict_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If X > wid Or Y > hgt Then Exit Sub
    With newpal(bytes(X, Y))
        MsgBox "Palette index:" & Str$(bytes(X, Y)) & _
            vbCrLf & "Red:  " & Str$(.peRed) & _
            vbCrLf & "Green:" & Str$(.peGreen) & _
            vbCrLf & "Blue: " & Str$(.peBlue)
    End With
End Sub
' ***********************************************
' Load a new image file.
' ***********************************************
Private Sub mnuFileLoad_Click()
Dim fname As String
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Load the picture.
    WaitStart
    DoEvents
    LoadFromPict fname
    WaitEnd
End Sub
' ***********************************************
' End the application. (See also the QueryUnload
' event.)
' ***********************************************
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromVBar_Change()
    FromPict.Top = -FromVBar.Value
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromVBar_Scroll()
    FromPict.Top = -FromVBar.Value
End Sub
' ************************************************
' Update the image brightness.
' ************************************************
Private Sub ScrollBright_Change()
    ValueBright.Caption = Format$(ScrollBright.Value)
    If SettingValues Then Exit Sub
    UpdateColors
End Sub
' ************************************************
' Update the image brightness.
' ************************************************
Private Sub ScrollBright_Scroll()
    ScrollBright_Change
End Sub